home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / m68kernel.t < prev    next >
Text File  |  1988-02-05  |  21KB  |  620 lines
  1. (herald m68kernel (env tsys))
  2.  
  3. ;;; note that A1 must not be destroyed and nil-reg is in AN
  4. ;;; return is in TP
  5.  
  6. (define (m68-big-bang) 
  7.   (lap (big_bang icall-bad-proc
  8.         icall-wrong-nargs handle-stack-base
  9.         handle-undefined-effect
  10.         really-gc pc-code-vector  heap-overflow-error
  11.         call-fault-handler cont-wrong-nargs)
  12.  
  13.     (move .l  nil-reg (d@nil -3))            ; (cdr '()) = '()
  14.     (move .l  nil-reg (d@nil 1))             ; (car '()) = '()
  15.  
  16.     (move .l  P (d@nil slink/kernel))        ; save kernel pointer
  17.     (lea (label %undefined-effect) A3)
  18.     (move .l A3       (d@nil  slink/undefined-effect ))
  19.     (lea (label %make-extend) A3)
  20.     (move .l A3       (d@nil  slink/make-extend ))
  21.     (lea (label %make-pair) A3)
  22.     (move .l A3       (d@nil  slink/make-pair ))
  23.     (lea (label %nary-setup) A3)
  24.     (move .l A3       (d@nil  slink/nary-setup ))
  25.     (lea (label %set) A3)
  26.     (move .l A3       (d@nil  slink/set ))
  27.     (lea (label %icall) A3)
  28.     (move .l A3 (d@nil  slink/icall ))
  29.     (lea (label %cont-wrong-nargs) A3)
  30.     (move .l A3 (d@nil  slink/cont-wrong-nargs ))
  31.  
  32.     (lea (label %kernel-begin) A3)
  33.     (move .l A3 (d@nil slink/kernel-begin))
  34.     (lea (label %kernel-end) A3)
  35.     (move .l A3 (d@nil slink/kernel-end))
  36.  
  37.  
  38.     ;; initialize root process, stored in outer space?  
  39.     ;; zero  out extra registers
  40.  
  41.     (move .l ($ temp-block-size) S0)
  42. initialize-loop     
  43.     (clr .l (@-r sp))  
  44.     (sub .l ($ 4) S0)
  45.     (tst .l S0)
  46.     (j> initialize-loop)
  47.     (move .l SP TASK)                                ; load task reg
  48.     (add  .l ($ (fx+ %%task-header-offset 4)) SP)    ; allocate task block
  49.     (move .l ($ header/task) (@-r SP))               ; task header
  50.     (move .l SP A3)
  51.     (add  .l ($ 2) A3)
  52.     (move .l A3 (d@nil slink/root-process))         ; ptr to root and
  53.     (move .l A3 (d@nil slink/current-task))         ; current process
  54.  
  55.     ;; initialize stack
  56.     (pea  (d@r A3 0))                                ; task block
  57.     (move .l nil-reg (@-r SP))                       ; no parent
  58.     (clr  .l (@-r SP))                               ; active, no current sz
  59.     (move .l ($ (fixnum-ashl %%stack-size 2)) (@-r SP))    ; total stack size
  60.     (move .l ($ #xBADBAD) (@-r SP))                  ; distinguished value
  61.     (pea (label stack-base-template))                ; stack base
  62.  
  63.     ;; initialize root process
  64. ;++  (move .l SP A3)
  65. ;++  (add  .l ($ 2) A3)
  66. ;++  (move .l A3 (d@r TASK task/stack))       ; set stack in root-process
  67. ;++ what to do, task/stack is a fixnum not an extend as it should be!
  68.     (move .l SP (d@r TASK task/stack))       ; set stack in root-process
  69.     (clr  .l (d@r TASK task/extra-pointer))
  70.     (clr  .l (d@r TASK task/extra-scratch))
  71.     (move .l nil-reg (d@r TASK task/dynamic-state))
  72.     ;; initialize area,area-frontier and area-limit
  73.     (move .l nil-reg (d@r TASK task/doing-gc?))
  74.     (clr .l (d@r TASK task/foreign-call-cont))
  75.     (clr .l (d@r TASK task/critical-count))
  76.     (move .l nil-reg (d@r TASK task/k-list))
  77.     (move .l nil-reg (d@r TASK task/gc-weak-set-list))
  78.     (move .l nil-reg (d@r TASK task/gc-weak-alist-list))
  79.     (move .l nil-reg (d@r TASK task/gc-weak-table-list))
  80.     (move .l nil-reg (d@nil slink/snapper-freelist))
  81.     (move .l nil-reg (d@nil slink/pair-freelist))
  82.     (move .l (d@static P (static 'big_bang)) P)
  83.     (jmp (@r TP))
  84.  
  85.  
  86. %make-pair
  87.     ;; return pair in AN
  88.     (bset ($ 7) (d@r TASK task/critical-count))
  89.     (move .l (d@r TASK task/area-frontier) AN)
  90.     (add .l ($ 8) AN)
  91.     (cmp .l (d@r TASK task/area-limit) AN)
  92.     (j> %make-pair-heap-overflow)
  93. %make-pair-continue
  94.     (move .l AN (d@r TASK task/area-frontier))
  95.     (sub .l ($ (fx- 8 tag/pair)) AN)             
  96.     (and .b ($ #x7f) (d@r TASK task/critical-count))
  97.     (jn= %deferred-interrupts)
  98.     (rts)
  99.                    
  100. %make-pair-heap-overflow
  101.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  102.     (jsr (label %heap-overflow))
  103.     (move .l (d@r TASK task/area-frontier) AN)
  104.     (add .l ($ 8) AN)
  105.     (cmp .l (d@r TASK task/area-limit) AN)
  106.     (j> %horrible-heap-overflow)
  107.     (bset ($ 7) (d@r TASK task/critical-count))
  108.     (move .l nil-reg (d@r TASK task/doing-gc?))
  109.     (jbr %make-pair-continue)
  110.  
  111. %make-extend
  112.     ;; receive descriptor in An, size in S1, return extend in AN
  113.     (bset ($ 7) (d@r TASK task/critical-count))
  114.     (move .l (d@r TASK task/area-frontier) S2) ; get area-frontier
  115.     (add .l ($ 4) S1)
  116.     (add .l S2 S1)                          ; one for the descriptor
  117.     (cmp .l (d@r TASK task/area-limit) S1)
  118.     (j> %make-extend-heap-overflow)
  119. %make-extend-continue
  120.     (move .l S1 (d@r TASK task/area-frontier))
  121.     (move .l AN S1)
  122.     (move .l S2 AN)
  123.     (move .l S1 (@r AN))                   ; move in descriptor
  124.     (add .l ($ tag/extend) AN)
  125.     (and .b ($ #x7f) (d@r TASK task/critical-count))
  126.     (jn= %deferred-interrupts)
  127.     (rts)
  128.                      
  129. %make-extend-heap-overflow
  130.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  131.     (sub .l S2 S1)
  132.     (jsr (label %heap-overflow))
  133.     (move .l (d@r TASK task/area-frontier) S2) ; get area-frontier
  134.     (add .l S2 S1)                          
  135.     (cmp .l (d@r TASK task/area-limit) S1)
  136.     (j> %horrible-heap-overflow)
  137.     (bset ($ 7) (d@r TASK task/critical-count))
  138.     (move .l nil-reg (d@r TASK task/doing-gc?))
  139.     (jbr %make-extend-continue)
  140.  
  141.  
  142. %heap-overflow   
  143.     (movem .l '(d0 d1 d2 d3 d4 d5) (@-r SP))                 ; save scratch registers
  144.     (move .l ($ temp-block-size) S0)
  145. save-loop                                  ; save temps
  146.     (move .l (index (d@r TASK -4) S0) (@-r SP))
  147.     (sub .l ($ 4) S0)
  148.     (j>= save-loop)
  149.     (movem .l '(a0 a1 a2 a3 a4 a5) (@-r SP))
  150.     (move .l (d@r SP (* (+ *no-of-registers* 3) 4)) A1)   ; one for TP 2 return
  151.     (pea (label pc-check-return))
  152.     (move .l nil-reg P)
  153.     (move .l (d@r P slink/kernel) P)
  154.     (move .l (d@static P (static 'pc-code-vector)) P)
  155.     (move .l (d@r P -2) TP)
  156.     (jmp (@r TP))                                ; call pc-code-vector
  157.     
  158. %icall                     
  159.   (move .w P S0)
  160.   (and .b ($ 3) S0)
  161.   (cmp .b ($ tag/extend) S0)                     ; check proc is extend
  162.   (jn= %icall-bad-proc)
  163.   (move .l (d@r P -2) TP)                         ; fetch template
  164.   (move .w TP S0)
  165.   (and .b ($ 3) S0)                 ; check proc is extend
  166.   (cmp .b ($ tag/extend) S0)
  167.   (jn= %icall-bad-proc)
  168.   (move .l  (d@r TP -2) S0)       ; check template is valid (high bit set)
  169.   (j>= %icall-bad-proc)
  170.   (cmp .b (d@r TP template/nargs) NARGS)         ; check number of args
  171.   (j= %icall-ok)
  172.   (j< %icall-wrong-nargs)
  173.   (btst ($ 30) S0)                            ; check nary bit
  174.   (j= %icall-wrong-nargs)
  175. %icall-ok
  176.   (jmp (@r TP))
  177.  
  178. %icall-bad-proc
  179.   (move .l a1 (d@r TASK task/t0))
  180.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  181.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  182.   (clr .l s0)
  183.   (jsr (label %nary-setup))
  184.   (move .l an a2)
  185.   (move .l p a1)
  186.   (move .l (d@nil slink/kernel) P)
  187.   (move .l (d@static P (static 'icall-bad-proc)) P)
  188.   (move .l (d@r P -2) TP)
  189.   (jmp  (@r TP))
  190.  
  191. %icall-wrong-nargs
  192.   (move .l a1 (d@r TASK task/t0))
  193.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  194.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  195.   (clr .l s0)
  196.   (jsr (label %nary-setup))
  197.   (move .l an a2)
  198.   (move .l p a1)
  199.   (move .l (d@nil slink/kernel) P)
  200.   (move .l (d@static P (static 'icall-wrong-nargs)) P)
  201.   (move .l (d@r P -2) TP)
  202.   (jmp  (@r TP))
  203.  
  204.  
  205. %deferred-interrupts
  206.     (movem .l '(d0 d1 d2 d3 d4 d5) (@-r SP))
  207.     (move .l ($ (fx+ temp-block-size 4)) S2)
  208. %int-save-loop                              ; save temps and extra p and s
  209.     (move .l (index (d@r TASK -8) S2) (@-r SP))
  210.     (sub .l ($ 4) S2)
  211.     (j>= %int-save-loop)
  212.     (movem .l '(a0 a1 a2 a3 a4 a5) (@-r SP))
  213.     (clr .l (@-r SP))               ; pc
  214.     (move .l (d@r SP (* (+ *pointer-temps* *scratch-temps* 15) 4)) (@-r SP))           
  215.     (clr .l (@-r SP))               ; no pointers on top
  216.     (move .l ($ (+ (fixnum-ashl (+ *pointer-temps* *scratch-temps* 17) 8)
  217.                    header/fault-frame))
  218.              (@-r SP))
  219.     (pea (label %int-return))
  220.     (move .l (d@nil slink/kernel) P)
  221.     (move .l (d@static P (static 'call-fault-handler)) P)
  222.     (move .l (d@r P -2) TP)                      
  223.     (jmp (@r TP))
  224.  
  225.  
  226. %kernel-begin
  227.  
  228. %cont-wrong-nargs
  229.   (neg .l nargs)
  230.   (move .l a1 (d@r TASK task/t0))
  231.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  232.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  233.   (clr .l s0)
  234.   (jsr (label %nary-setup))
  235.   (move .l an a2)
  236.   (lea (d@r sp 2) a1)
  237.   (move .l (d@nil slink/kernel) P)
  238.   (move .l (d@static P (static 'cont-wrong-nargs)) P)
  239.   (move .l (d@r P -2) TP)
  240.   (jmp  (@r TP))
  241.                 
  242. %post-gc-nary-setup
  243.   (move .l ($ -1) S1)
  244.   (jbr %real-nary-setup)                   
  245.   
  246. %nary-setup   
  247.   (clr .l S1)       
  248. %real-nary-setup                                ; not just after GC
  249.   (asl .l ($ 2) S0)                                 ; required args in S0
  250.   (sub .l ($ 2) NARGS)         
  251.   (asl .l ($ 2) NARGS)                                 ; m68 index mode
  252.   (move .l nil-reg AN)
  253.   (move .l P (d@r TASK task/extra-pointer))
  254.   (bset ($ 7) (d@r TASK task/critical-count))
  255.   (jmp (label %nary-test))
  256. %nary-loop
  257.   (move .l AN P)                               ; accumulate in P
  258.   (move .l (d@r TASK task/area-frontier) AN)
  259.   (add .l ($ 8) AN)
  260.   (cmp .l (d@r TASK task/area-limit) AN)
  261.   (j> %nary-make-pair-heap-overflow)
  262. %nary-make-pair-continue                        ; lose, lose
  263.   (move .l AN (d@r TASK task/area-frontier))
  264.   (sub .l ($ (fx- 8 tag/pair)) AN)             
  265.   (move .l P (d@r AN -3))                      ; set cdr
  266.   (move .l (index (@r TASK) NARGS) (d@r AN 1)) ; set car
  267.   (sub .l ($ 4) NARGS)
  268. %nary-test
  269.   (cmp .l NARGS S0)
  270.   (j<= %nary-loop)
  271.   (tst .l S1)
  272.   (jn= nary-clear-extras)
  273.   (move .l (d@r TASK task/extra-pointer) P)                            
  274.   (and .b ($ #x7f) (d@r TASK task/critical-count))
  275.   (jn= %deferred-interrupts)
  276.   (rts)     
  277. nary-clear-extras
  278.   (cmp .l ($ 12) S0)
  279.   (j>= foo45)
  280.   (move .l ($ 12) S0)
  281. foo45
  282.   (clr .l (index (@r TASK) S0))
  283.   (add .l ($ 4) S0)
  284.   (cmp .l ($ temp-block-size) S0)
  285.   (j< foo45)
  286.   (lea (label %nary-setup) P)
  287.   (move .l P (d@nil slink/nary-setup))
  288.   (move .l (d@r TASK task/extra-pointer) P)                            
  289.   (and .b ($ #x7f) (d@r TASK task/critical-count))
  290.   (jn= %deferred-interrupts)
  291.   (rts)     
  292.  
  293.   
  294.   
  295.  
  296. %nary-make-pair-heap-overflow
  297.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  298.     (jsr (label %heap-overflow))
  299.     (move .l (d@r TASK task/area-frontier) AN)
  300.     (add .l ($ 8) AN)
  301.     (cmp .l (d@r TASK task/area-limit) AN)
  302.     (j> %horrible-heap-overflow)
  303.     (bset ($ 7) (d@r TASK task/critical-count))
  304.     (move .l nil-reg (d@r TASK task/doing-gc?))
  305.     (jbr %nary-make-pair-continue)
  306.  
  307. %set                                        ; a location is (unit  . index)
  308.    ;;  vcell in extra-pointer
  309.    (bset ($ 7) (d@r TASK task/critical-count))
  310.    (movem .l '(a0 a1 a2 a3 a4) (@-r sp))
  311.    (move .l (d@r TASK task/extra-pointer) a3)
  312.    (move .l (d@r A3 6) A1)                  ; get locations
  313.    (move .l (d@r A1 2) A1)                  ; get the vector in A1
  314.    (move .l (d@r A1 -2) SCRATCH)
  315.    (asr .l ($ 8) SCRATCH)                        ; length in S0
  316.    (asl .l ($ 2) SCRATCH)
  317.    (jbr %set-test)
  318. %set-loop
  319.    (move .l (d@nil slink/snapper-freelist) an)
  320.    (cmp .l an nil-reg)
  321.    (j= cons-snapper)
  322.    (move .l (d@r an 1) p)
  323.    (move .l (d@r an -3) (d@nil slink/snapper-freelist))
  324.    (move .l (d@nil slink/pair-freelist) (d@r an -3))
  325.    (move .l an (d@nil slink/pair-freelist))
  326. %real-top
  327.    (move .l (index (d@r A1 -6) SCRATCH) A2)      ; get unit
  328.    (move .l (index (d@r A1 -2) SCRATCH) AN)      ; get index
  329.    (move .l (d@r a3 2) (d@r p 2))
  330.    (move .l a2 (d@r p 6))
  331.    (move .l an (d@r p 10))
  332.    (move .l p (index (d@r A2 2) AN))
  333.    (sub .l ($ 8) SCRATCH)
  334. %set-test
  335.    (tst .l SCRATCH)
  336.    (jn= %set-loop)
  337.    (movem .l (@r+ sp) '(a0 a1 a2 a3 a4))
  338.    (and .b ($ #x7f) (d@r TASK task/critical-count))
  339.    (jn= %deferred-interrupts)
  340.    (rts)
  341. cons-snapper
  342.    (move .l (d@r TASK task/area-frontier) AN)
  343.    (add .l ($ 16) AN)
  344.    (cmp .l (d@r TASK task/area-limit) AN)
  345.    (j> %set-heap-overflow)
  346. %set-continue                        ; lose, lose
  347.    (move .l AN (d@r TASK task/area-frontier))
  348.    (lea (d@r an -14) p)
  349.    (lea (label link-snapper) a2)
  350.    (move .l a2 (d@r p -2))
  351.    (jbr %real-top)
  352. %set-heap-overflow
  353.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  354.     (move .l ($ (+ (fixnum-ashl 5 16) (fixnum-ashl 1 8) header/vframe )) (@-r sp))
  355.     (move .l (d@r sp 24) (@-r sp))
  356.     (jsr (label %heap-overflow))
  357.     (move .l (@r sp) (d@r sp 28))
  358.     (add .w ($ 8) sp)
  359.     (move .l (d@r TASK task/area-frontier) AN)
  360.     (add .l ($ 16) AN)
  361.     (cmp .l (d@r TASK task/area-limit) AN)
  362.     (j> %horrible-heap-overflow)
  363.     (bset ($ 7) (d@r TASK task/critical-count))
  364.     (move .l nil-reg (d@r TASK task/doing-gc?))
  365.     (jbr %set-continue)
  366.  
  367. %kernel-end
  368.  
  369. %horrible-heap-overflow
  370.   (add .w ($ 4) SP)
  371.   (bclr ($ 7) (d@r TASK task/critical-count))
  372.   (move .l nil-reg (d@r TASK task/doing-gc?))
  373.   (move .l (d@nil slink/kernel) P)
  374.   (move .l (d@static P (static 'heap-overflow-error)) P)
  375.   (move .l (d@r P -2) TP)
  376.   (jmp (@r TP))
  377.   
  378. %undefined-effect    ; a1 is string
  379.   (move .l TP A2)              ; template
  380.   (move .l (d@nil slink/kernel) P)
  381.   (move .l (d@static P (static 'handle-undefined-effect)) P)
  382.   (move .l (d@r P -2) TP)
  383.   (jmp (@r TP))
  384.   
  385.  
  386.  
  387. ))                                     
  388.  
  389. (lap-template (0 0 -1 t stack %int-return-handler)
  390. %int-return
  391.     (bset ($ 6) (d@r task task/critical-count))
  392.     (move .l (d@r SP 12) (d@r SP (* (+ *pointer-temps* *scratch-temps* 19) 4)))
  393.     (add .w ($ 20) sp)        ; pop template,header,pointers on stack,hack top,pc
  394.     (movem .l (@r+ SP) '(a0 a1 a2 a3 a4 a5))
  395.     (move .l ($ -8) S0)
  396. %int-return-restore-loop                                  ; restore temps
  397.     (move .l (@r+ SP) (index (@r TASK) S0))
  398.     (add .l ($ 4) S0)
  399.     (cmp .l ($ temp-block-size) S0)          
  400.     (j< %int-return-restore-loop)
  401.     (movem .l (@r+ SP) '(d0 d1 d2 d3 d4 d5))
  402.     (bclr ($ 6) (d@r task task/critical-count))
  403.     (rts)
  404. %int-return-handler
  405.     (move .l nil-reg an)
  406.     (rts))
  407.  
  408.  
  409.  
  410.  
  411. (define (clear-extra-registers)
  412.   (lap ()
  413.     (move .l ($ -4) S0)
  414. zero-loop                                  ; restore temps
  415.     (clr .l (index (@r TASK) S0))
  416.     (add .l ($ 4) S0)
  417.     (cmp .l ($ temp-block-size) S0)
  418.     (j< zero-loop)
  419.     (move .l ($ -2) NARGS)
  420.     (move .l (@r sp) tp)
  421.     (jmp (@r tp))))
  422.     
  423.  
  424. (lap-template (0 0 -1 t stack pc-check-return-handler) 
  425. pc-check-return
  426.     (add .l ($ 4) SP)                            ; pop return address
  427.     (move .l A1 (@-r SP))                        ; code vector of pc
  428.     (pea (d@r A1 -2))                            ; fixnumized code vector
  429.     (pea (label gc-template))
  430.     (move .l (d@nil slink/kernel) P)
  431.     (move .l (d@static P (static 'really-gc)) P)
  432.     (move .l (d@r P -2) TP)
  433.     (jmp (@r TP))
  434. pc-check-return-handler
  435.   (move .l nil-reg AN)
  436.   (rts))
  437.  
  438.                  
  439. ;;; sizes of gc template:
  440. ;;; pointer -- n registers + n temps + 1 extra + 2 code vector + tp
  441. ;;; scratch -- gc return address + 1 other + n registers + n temps
  442.  
  443. (lap-template ((+ *pointer-temps* *pointer-registers* 4) 
  444.                (+ *scratch-temps* *scratch-registers* 2) 
  445.                -1 t stack gc-template-handler)       ;; see gc.t
  446. gc-template               
  447.   (lea (label %post-gc-nary-setup) P)
  448.   (move .l P (d@nil slink/nary-setup))
  449.   (add .w ($ 4) SP)                                  ; pop template 
  450.   (move .l (@r+ SP) S0)                              ; pop old code (fixnum)
  451.   (move .l (@r+ SP) S1)                              ; pop relocated code
  452.   (cmp .l S1 nil-reg)
  453.   (j= gc-continue)                                   ; not relocated
  454.   (sub .l ($ 2) S1)                                  ; fixnumize new code
  455.   (move .l (d@r SP (* (+ *no-of-registers* 3) 4)) S2); get old pc
  456.   (sub .l S0 S2)                                     ; offset
  457.   (add .l S2 S1)                                     ; new pc
  458.   (move .l S1 (d@r SP (* (+ *no-of-registers* 3) 4))); update pc
  459. gc-continue
  460.   (movem .l (@r+ SP) '(a0 a1 a2 a3 a4 a5))
  461.   (move .l ($ -4) S0)
  462. restore-loop                                  ; restore temps
  463.   (move .l (@r+ SP) (index (@r TASK) S0))
  464.   (add .l ($ 4) S0)
  465.   (cmp .l ($ temp-block-size) S0)
  466.   (j< restore-loop)
  467.   (movem .l (@r+ SP) '(d0 d1 d2 d3 d4 d5))
  468.   (rts)
  469. gc-template-handler
  470.   (move .l nil-reg AN)
  471.   (rts))
  472.                           
  473.                                                             
  474. (lap-template (0 0 0 nil stack stack-base-handler)
  475. stack-base-template
  476.   (jmp (*d@nil slink/undefined-effect))
  477. stack-base-handler
  478.   (move .l (d@nil slink/kernel) AN)
  479.   (move .l (d@static AN (static 'handle-stack-base)) A1)
  480.   (jmp (*d@nil slink/dispatch-label)))
  481.  
  482.  
  483. (define (lap-relocate frame old-tp new-tp offset)
  484.   (lap ()                 
  485.     (move .l (d@r TASK 12) S0)           ; offset
  486.     (move .l (index (d@r A1 2) S0) S1)   ; code
  487.     (sub .l A2 S1)                       ; code-offset
  488.     (add .l S1 A3)                       ; new code
  489.     (move .l A3 (index (d@r A1 2) S0))
  490.     (move .l ($ -1) NARGS)
  491.     (move .l (@r sp) tp)
  492.     (jmp (@r tp))))
  493.  
  494.     
  495.  
  496. (define (current-task)
  497.  (lap ()
  498.   (move .l TASK A1)
  499.   (add .l ($ (fx+ %%task-header-offset 2)) A1)   ; offset is negative !
  500.   (move .l ($ -2) nargs)
  501.   (move .l (@r sp) tp)
  502.   (jmp (@r tp))))
  503.  
  504.   
  505. (define-foreign gc_interrupt ("GC_INTERRUPT") ignore)
  506.  
  507. ;;; Hack for getting into the debugger.
  508.  
  509. (define (@@ address)    ; randomness
  510.   (lap ()
  511.     (add .l ($ 2) a1)
  512.     (move .l ($ -2) nargs)
  513.     (move .l (@r sp) tp)
  514.     (jmp (@r tp))))
  515.  
  516.  
  517. (define (bpt . args)
  518.     (lap ()
  519.         (trap (number 9))
  520.         (move .l ($ 0) s0)
  521.         (move .l s0 a1)
  522.         (move .l ($ -2) NARGS)
  523.     (move .l (@r sp) tp)
  524.     (jmp (@r tp))))
  525.  
  526. (define (crawl-exhibit-fault-frame frame)
  527.   (cond ((not (foreign-fault-frame? frame))       ; foreign
  528.          (print-register frame 'p 3)
  529.          (print-register frame 'a1 4)
  530.          (print-register frame 'a2 5)
  531.          (print-register frame 'a3 6)
  532.          (print-register frame 'an 7)
  533.          (print-register frame 'tp 8))
  534.         (else
  535.          (format t " In foreign code; no information available~%"))))
  536.  
  537. (define (trace-fault-frame frame)
  538.   (cond ((alt-bit-set? frame)          
  539.          (move-object (make-pointer frame 0)))           ; foreign cont
  540.         (else
  541.          (let ((tp (extend-elt frame 8)))                ; old TP
  542.            (trace-pointers (make-pointer frame 2) 6)     ; trace registers
  543.            (trace-pointers (make-pointer frame 9)        ; trace temps
  544.                            (fx+ *pointer-temps* 1))
  545.            (let ((ptrs (extend-elt frame 0))             ; trace top of stack
  546.                  (size (fault-frame-slots frame)))
  547.              (trace-pointers (make-pointer frame (fx- size 1)) ptrs))
  548.            (if (eq? (extend-elt frame 1) 0)              ; hack-top-of-stack?
  549.                (relocate-random-code frame 2 tp)         ; relocate PC
  550.                (relocate-random-code frame 1 tp))))))    ; relocate top-of-stack
  551.  
  552. (define (relocate-random-code frame offset old-tp)
  553.   (if (in-old-space? (extend-elt frame offset))
  554.       (lap-relocate frame old-tp (extend-elt frame 8) offset)))
  555.  
  556. (define (make-link-snapper value unit i)
  557.   (lap ()
  558.     (move .l (d@nil slink/snapper-freelist) p)
  559.     (cmp .l p nil-reg)
  560.     (j= cons-snapper-1)
  561.     (move .l (d@r p 1) an)
  562.     (move .l (d@r p -3) (d@nil slink/snapper-freelist))
  563.     (move .l (d@nil slink/pair-freelist) (d@r p -3))
  564.     (move .l p (d@nil slink/pair-freelist))
  565. foobarfoo
  566.     (move .l a1 (d@r an 2))
  567.     (move .l a2 (d@r an 6))
  568.     (move .l a3 (d@r an 10))
  569.     (move .l an a1)
  570.     (move .l ($ -2) nargs)
  571.     (move .l (@r sp) tp)
  572.     (jmp (@r tp))
  573. cons-snapper-1    
  574.     (lea (label link-snapper) an)
  575.     (move .l ($ 12) s1)
  576.     (jsr (label %make-extend))
  577.     (jbr foobarfoo)))
  578.  
  579. (define *link-snapper-template*
  580. (lap-template (3 0 1 t heap handle-snapper)
  581. link-snapper
  582.   (move .l p an)
  583.   (move .l (d@r p 2) p)
  584.   (move .w P S0)
  585.   (and .b ($ 3) S0)
  586.   (cmp .b ($ tag/extend) S0)                     ; check proc is extend
  587.   (jn= %icall-bad-proc)
  588.   (move .l (d@r P -2) TP)                         ; fetch template
  589.   (move .w TP S0)
  590.   (and .b ($ 3) S0)                 ; check proc is extend
  591.   (cmp .b ($ tag/extend) S0)
  592.   (jn= %icall-bad-proc)
  593.   (move .l  (d@r TP -2) S0)       ; check template is valid (high bit set)
  594.   (j>= %icall-bad-proc)
  595.   (cmp .b (d@r TP template/nargs) NARGS)         ; check number of args
  596.   (j= snap-link)
  597.   (j< %icall-wrong-nargs)
  598.   (btst ($ 30) S0)                            ; check nary bit
  599.   (j= %icall-wrong-nargs)
  600. snap-link
  601.   (move .l an (d@r task task/extra-pointer))
  602.   (move .l (d@r an 10) s0)
  603.   (move .l (d@r an 6) an)
  604.   (move .l p (index (d@r an 2) s0))
  605.   (move .l (d@nil slink/pair-freelist) an)
  606.   (cmp .l an nil-reg)
  607.   (j= cons-pair)
  608.   (move .l (d@r an -3) (d@nil slink/pair-freelist))
  609. consed-pair
  610.   (move .l (d@r task task/extra-pointer) (d@r an 1))
  611.   (move .l (d@nil slink/snapper-freelist) (d@r an -3))
  612.   (move .l an (d@nil slink/snapper-freelist))
  613.   (jmp (@r TP))
  614. cons-pair
  615.   (jsr (label %make-pair))
  616.   (jbr consed-pair)
  617. handle-snapper
  618.   (move .l nil-reg AN)
  619.   (rts)))
  620.